home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PASCALL
/
NEETVGA
/
RGB
/
FERN4.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-02-26
|
7KB
|
212 lines
{****************************************************************************}
{*********************** ***********************}
{** R-G-B Demonstrator **}
{**************************** ****************************}
{** Copyrighted February 12, 1993 **}
{** (C) To Authors **}
{** Fernando Padilla **}
{** Stephen Markham **}
{****************************** ******************************}
{****************************************************************************}
uses
roger,crt;
const
pause=15;
blendframes=100;
base=15;
top=63;
type
pRGB=(R,RRRG,RRG,RRRGG,RG,RRGGG,RGG,RGGG,G,GGGB,GGB,GGGBB,GB,GGBBB,GBB,GBBB,B,BBBR,BBR,BBBRR,BR,BBRRR,BRR,BRRR,W);
cRGB=record
color,
red,
green,
blue:byte;
end;
var
buff:char;
procedure updatergb(a,b,c,d:integer);
begin
textcolor(1);
gotoxy(1,1);
write('Color:');
writeln(a:14);
gotoxy(1,3);
write('RED:');
writeln(b:16);
gotoxy(1,4);
write('GREEN:');
writeln(c:14);
gotoxy(1,5);
write('BLUE:');
writeln(d:15);
end;
Procedure saycolor(a,b,c,d:integer; updat:boolean);
function rat(percent,high:byte):integer;
begin
rat:=trunc(high*(percent/100));
end;
function inverse(a,b:integer):integer;
begin
inverse:=abs(a-b);
end;
begin
PutColor(a,rat(b,top),rat(c,top),rat(d,top));
PutColor(a+1,inverse(rat(b,top),top),inverse(rat(c,top),top),inverse(rat(d,top),top));
if updat then UpdateRGB(a,b,c,d);
end;
procedure control(display:boolean);
var
palette:rogerrgbpalette;
color:prgb;
stop:boolean;
function inverse(a,b:integer):integer;
begin
inverse:=abs(a-b);
end;
Procedure FadeColor(c:pRGB; display:boolean; var stop:boolean);
var
percent:byte;
Procedure DoColor(c:pRGB; i:byte; var display,stop:boolean);
Begin
if not stop then
begin
Case c of
R: SayColor(0,i,0,0,display);
RRRG: SayColor(0,i,i div 3,0,display);
RRG: SayColor(0,i,i div 2,0,display);
RRRGG: SayColor(0,i,(i*2) div 3,0,display);
RG: SayColor(0,i,i,0,display);
RRGGG: SayColor(0,(i*2) div 3,i,0,display);
RGG: SayColor(0,i div 2,i,0,display);
RGGG: SayColor(0,i div 3,i,0,display);
G: SayColor(0,0,i,0,display);
GGGB: SayColor(0,0,i,i div 3,display);
GGB: SayColor(0,0,i,i div 2,display);
GGGBB: SayColor(0,0,i,(i*2) div 3,display);
GB: SayColor(0,0,i,i,display);
GGBBB: SayColor(0,0,(i*2) div 3,i,display);
GBB: SayColor(0,0,i div 2,i,display);
GBBB: SayColor(0,0,i div 3,i,display);
B: SayColor(0,0,0,i,display);
BBBR: SayColor(0,i div 3,0,i,display);
BBR: SayColor(0,i div 2,0,i,display);
BBBRR: SayColor(0,(i*2) div 3,0,i,display);
BR: SayColor(0,i,0,i,display);
BBRRR: SayColor(0,i,0,(i*2) div 3,display);
BRR: SayColor(0,i,0,i div 2,display);
BRRR: SayColor(0,i,0,i div 3,display);
W: SayColor(0,i,i,i,display);
end;
delay(pause);
stop:=keypressed;
end;
end;
Begin
if not stop then
begin
For percent := 0 To 100 Do Docolor(c,percent,display,stop);
For percent := 100 DownTo 0 Do Docolor(c,percent,display,stop);
end;
end;
Begin
store(palette);
stop:=false;
Repeat
for color:=R to W do FadeColor(color,display,stop);
Until KeyPressed or stop;
Restore(palette);
End;
procedure control3(display:boolean);
var
palette:rogerrgbpalette;
c:prgb;
a,d:crgb;
stop:boolean;
procedure park(a,b,c,d:integer; var p:crgb);
begin
p.color:=a;
p.red:=b;
p.green:=c;
p.blue:=d;
end;
procedure getcolor(c:prgb; var p:crgb; i:integer; var stop:boolean);
begin
if not stop then
Case c of
R: park(0,i,0,0,p);
RRRG: park(0,i,i div 3,0,p);
RRG: park(0,i,i div 2,0,p);
RRRGG: park(0,i,(i*2) div 3,0,p);
RG: park(0,i,i,0,p);
RRGGG: park(0,(i*2) div 3,i,0,p);
RGG: park(0,i div 2,i,0,p);
RGGG: park(0,i div 3,i,0,p);
G: park(0,0,i,0,p);
GGGB: park(0,0,i,i div 3,p);
GGB: park(0,0,i,i div 2,p);
GGGBB: park(0,0,i,(i*2) div 3,p);
GB: park(0,0,i,i,p);
GGBBB: park(0,0,(i*2) div 3,i,p);
GBB: park(0,0,i div 2,i,p);
GBBB: park(0,0,i div 3,i,p);
B: park(0,0,0,i,p);
BBBR: park(0,i div 3,0,i,p);
BBR: park(0,i div 2,0,i,p);
BBBRR: park(0,(i*2) div 3,0,i,p);
BR: park(0,i,0,i,p);
BBRRR: park(0,i,0,(i*2) div 3,p);
BRR: park(0,i,0,i div 2,p);
BRRR: park(0,i,0,i div 3,p);
W: park(0,i,i,i,p);
end;
end;
procedure blend(p1,p2:crgb; var stop,display:boolean);
var
a:byte;
function increment(n1,n2,p:integer):integer;
begin
increment:=trunc((((n2-n1)/blendframes)*p)+n1);
end;
begin
for a:=0 to blendframes do if not stop then begin saycolor(p1.color,increment(p1.red,p2.red,a),
increment(p1.green,p2.green,a),
increment(p1.blue,p2.blue,a),display);
delay(pause);
stop:=keypressed;
end;
end;
begin
store(palette);
stop:=false;
getcolor(pred(w),a,0,stop);
getcolor(r,d,100,stop);
blend(a,d,stop,display);
repeat
for c:=r to pred(pred(w)) do
begin
getcolor(c,a,100,stop);
getcolor(succ(c),d,100,stop);
blend(a,d,stop,display);
end;
getcolor(pred(w),a,100,stop);
getcolor(r,d,100,stop);
blend(a,d,stop,display);
until stop;
restore(palette);
end;
begin
clrscr;
window(30,11,51,17);
control(not(pos('false',paramstr(1))>0));
buff:=readkey;
buff:=readkey;
control3(not(pos('false',paramstr(1))>0));
end.